home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / FORTH / FORTHMAC / OLD / TOOLS1 / !Forthmacs.lib.sort < prev    next >
Text File  |  1996-05-27  |  4KB  |  97 lines
  1. \ Heap Sort
  2. \
  3. \ Input:
  4. \    Array of records, indexed from 1 to #records.  Array index 0
  5. \       refers to an extra record location which is used as a temporary.
  6. \    The arrays can be in any format you choose, so long as you
  7. \    provide appropriate rec-copy and rec-test routines.
  8. \
  9. \ You must provide implementations for these deferred words:
  10. \          rec-copy   ( i j -- )       \ Copies a record from position i to j
  11. \          rec-test   ( i j -- flag )  \ True if record(i) is > record(j)
  12. \    For both of these functions, if either index i or j is 0, then the
  13. \    temporary record location is used.
  14. \
  15. \ Output:
  16. \    The array from 1 to #records is left sorted in ascending order
  17. \    according to the comparison function rec-test .
  18. \
  19. \ See forth/test.dir/test-sort.f  for an example use.
  20.  
  21. \ Discussion:
  22. \ Heap sort is a very clever sorting algorithm, with some nice properties:
  23. \   1) The sort is done in-place.  Only one extra record location is required.
  24. \   2) The worst-case complexity is O(n log n)
  25. \ Drawbacks:
  26. \   1) The inner loop requires 2 comparisons.
  27. \   2) The order of input records with duplicate keys is not necessarily
  28. \      preserved in the sorted output.
  29. \   3) The algorithm is not intuitive.  Consult a sorting (e.g. Knuth Vol.3)
  30. \      or data structures (e.g. Horowitz and Sahni) text for more information.
  31. \
  32. \ As used here, a heap is a binary tree with the following property:
  33. \   Each node is greater than or equal to either of its children.
  34. \ Note that a heap is not necessarily completely sorted, because no ordering
  35. \ is imposed between siblings.  Furthermore, it is possible that the children
  36. \ of a node might be greater than the node's brother.
  37. \
  38. \ The algorithm relies on a clever representation of a heap as an array.
  39. \ No tree pointers are necessary, because the heap is a bushy tree: every
  40. \ level except the last is completely populated.  This yields the following
  41. \ representation:  Node 1 is the root of the tree.  Nodes 2 and 3 are the
  42. \ level 1 siblings, nodes 4 5 6 and 7 are the level 2 siblings, etc.
  43. \ This allows you to traverse the tree with 2* , 2/ , and 1+ .
  44.  
  45. defer rec-copy    ( i j -- )    \ Copies record from position i to position j
  46. defer rec-test    ( i j -- flag )    \ Compares record i with record j
  47. \ Convert the initial unordered array into a heap
  48.  
  49. : create-heap    ( #records -- )
  50.     1+  2
  51.     do    i 0 rec-copy   i        ( node# )
  52.         begin    dup 2/ 0 over rec-test    ( node# parent flag )
  53.         while    tuck swap rec-copy    ( parent )
  54.         repeat                ( node# parent )
  55.             drop 0 swap rec-copy
  56.     loop ;
  57.  
  58. \ Reconstruct the heap by inserting the record stored in the temporary
  59. \ location 0.  The root of the heap is empty because we extracted it and
  60. \ put it at location rec#.  We descend the tree, copying records up into
  61. \ vacated spaces, until we find the place where the temporary record fits.
  62. variable more?
  63. : fix-heap    ( max-rec# -- )
  64.     1                    ( rec# parent )
  65.     more? on
  66.     begin    ( rec# parent )    2dup 2* 1+ >=    \ Exit if we have reached a leaf node
  67.         \ or if the previous iteration found the right place for the key
  68.         more? @ and
  69.     while    ( rec# parent )    dup 2*        ( rec# parent left-child )
  70.         \ If the parent node has more than one child, find the largest one
  71.         2 pick  over 1+  >
  72.         if dup dup 1+ swap rec-test if 1+ then then
  73.             \ Do we have to move the child up?
  74.             dup 0  rec-test            ( rec# parent child flag )
  75.             if    tuck swap rec-copy    ( rec# child )
  76.             else    drop  more? off        ( rec# parent )
  77.             then
  78.     repeat                    ( rec# parent' )
  79.     0 swap rec-copy    drop ;
  80.  
  81. : heap-sort    ( #records -- )
  82.     dup create-heap  ( #records )
  83.     \ Now the array is a heap.  Repeatedly extract the root node of the
  84.     \ heap, put it in its correct place in the output array, and reconstruct
  85.     \ the heap by inserting the displaced record back into the heap.
  86.     begin    ( rec# )
  87.         \ Loop Invariant: The array from [1..rec#] is a heap.
  88.         \ The arrary from [rec#..#records] is sorted in ascending order.
  89.         dup 2 >=
  90.     while    ( rec# )
  91.         dup 0 rec-copy    \ Save record[rec#] in temporary location 0
  92.         1 over rec-copy   \ Replace it with the record from the root of the heap
  93.         dup fix-heap  ( rec# )
  94.         1-
  95.     repeat
  96.     drop ;
  97.